home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
doors_1
/
fd200.zip
/
FD_DOS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-27
|
11KB
|
452 lines
procedure wait_for_key;
var anykey : char;
begin
repeat until keypressed;
anykey := readkey;
if (anykey = #0) then anykey := readkey;
end;
procedure press_key;
begin
write(' Press any key to continue');
wait_for_key;
writeln;
end;
procedure nbr_input(var nbr : integer);
var num : any_string;
n,e : integer;
begin
num := '';
repeat
repeat
key := readkey;
until (key in [^H,^M,#27,'0'..'9']);
if (key = #0) then
begin
key := readkey; { destroy all function key input }
key := null;
end;
case key of
#27 : num := ''; { cancel input }
^H : if length(num) > 0 then { backspace }
begin
num[0] := chr(ord(num[0]) - 1);
write(^H,' ',^H);
end;
^M,
null : ; { all values entered }
else
begin
write(key);
num := num + key;
end;
end;
until (key in [#27,^M]);
val(num,n,e);
if (length(num) > 0) then nbr := n;
end;
function str_input(n : integer): any_string;
var inp : any_string;
i : integer;
begin
inp := '';
repeat
repeat
key := readkey;
until (key in [^H,^M,#27,#32..#127]);
if (key = #27) AND keypressed then
begin
key := readkey; { destroy all function key input }
key := null;
end;
case key of
#27 : inp := ''; { cancel input }
^H : if length(inp) > 0 then { backspace }
begin
inp[0] := chr(ord(inp[0]) - 1);
write(^H,' ',^H);
end;
^M,
null : ; { return }
else
if length(inp) < n then
begin
write(key);
inp := inp + key;
end;
end;
until (key in [#27,^M]);
str_input := inp;
end;
procedure Frame(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
var I : Integer;
begin {Frame}
GotoXY(UpperLeftX, UpperLeftY);
Write(chr(218));
for I := (UpperLeftX + 1) to (LowerRightX - 1) do
begin
Write(chr(196));
end;
Write(chr(191));
for I := (UpperLeftY + 1) to (LowerRightY - 1) do
begin
GotoXY(UpperLeftX , I); Write(chr(179));
GotoXY(LowerRightX, I); Write(chr(179));
end;
GotoXY(UpperLeftX, LowerRightY);
Write(chr(192));
for I := (UpperLeftX + 1) to (LowerRightX - 1) do
begin
Write(chr(196));
end;
Write(chr(217));
end; {Frame}
function Date: DateString;
var
gy, gm, gd, gdw : word;
month,day: string[2];
year: string[2];
yr: string[4];
begin
GetDate(gy,gm,gd,gdw);
str(gy,yr);
str(gd,day);
str(gm,month);
year := ' ';
year[1] := yr[3];
year[2] := yr[4];
if (month[0] = ^A) then month := '0' + month;
if (day[0] = ^A) then day := '0' + day;
date := month+'/'+day+'/'+year;
end;
function todays_log_name: File_Type;
var s : File_Type;
begin
s := date;
s[3] := '_';
s[6] := '_';
s := s + '.LOG';
todays_log_name := s;
end;
function time: TimeString;
var
gh, gm, gs, gs100 : word;
hour,min: string[2];
begin
GetTime(gh, gm, gs, gs100);
begin
str(gh, hour); {convert to string}
str(gm,min); { " }
end;
if (hour[0] = #1) then hour := '0' + hour;
if (min[0] = #1) then min := '0' + min;
time := hour + ':' + min;
end;
procedure set_date_time;
var sec100 : word;
begin
if (time_zone <> 0) then
begin
GetDate(year,month,day,dow);
GetTime(hour,min,sec,sec100);
hour := hour + time_zone;
if (hour > 23) then
begin
hour := hour - 24;
day := day + 1;
if (day > nbr_days[month]) then
begin
day := 1;
month := month + 1;
if (month > 12) then
begin
month := 1;
year := year + 1;
end;
end;
end;
SetDate(year,month,day);
SetTime(hour,min,sec,sec100);;
end;
end;
procedure reset_date_time;
var sec100 : word;
begin
if (time_zone <> 0) then
begin
GetDate(year,month,day,dow);
GetTime(hour,min,sec,sec100);
hour := hour - time_zone;
if (hour < 0) then
begin
hour := hour + 24;
day := day - 1;
if (day = 0) then
begin
month := month - 1;
if (month = 0) then
begin
month := 12;
year := year - 1;
end;
day := nbr_days[month];
end;
end;
SetDate(year,month,day);
SetTime(hour,min,sec,sec100);;
end;
end;
procedure directory;
type
filename = string[13];
dtapointer = ^dtarecord;
dtarecord = record
dosreserved : array[1..21] of byte;
attribute : byte;
filetime,
filedate,
sizelow,
sizehigh : integer;
foundname : array[1..13] of char;
end;
const
seekattrib = $10;
var
transferrec : dtapointer;
matchptrn : file_type;
retname : filename;
filsize : real;
count : integer;
nofind, lastfile, subdirec : boolean;
local_image : array[0..3999] of byte;
procedure pointdta(var dtarec : dtapointer);
const getdta = $2F00;
var regs : registers;
begin
regs.ax := getdta;
MsDos(regs);
dtarec := ptr(regs.es,regs.bx);
end;
function sizeoffile(hiword, loword : integer) : real;
var bigno, size : real;
begin
bigno := (MaxInt *2.0) + 2;
if (hiword < 0) then size := (bigno + hiword) * bigno
else size := hiword * bigno;
if (loword >= 0) then size := size + loword
else size := size + (bigno + loword);
sizeoffile := size;
end;
procedure findfirst(pattern : file_type;
var found : filename;
var size : real;
var nomatch : boolean;
var lastone : boolean;
var subdir : boolean);
const findfirst = $4E00;
type asciiz = array[1..64] of char;
var filespec : asciiz;
regs : registers;
posinstr,
count : integer;
foundlen : byte absolute found;
begin
for posinstr := 1 to length(pattern) do
filespec[posinstr] := pattern[posinstr];
filespec[length(pattern)+1] := null;
with regs do
begin
ds := seg(filespec);
dx := ofs(filespec);
cx := seekattrib;
ax := findfirst;
MsDos(regs);
if (flags AND 1) > 0 then
begin
case ax of
2 : begin
nomatch := TRUE;
lastone := TRUE;
end;
18 : begin
nomatch := FALSE;
lastone := TRUE;
end;
end;
end
else
begin
nomatch := FALSE;
lastone := FALSE;
end;
end;
if (NOT nomatch) then
with transferrec^ do
begin
found := foundname;
count := 0;
while found[count] <> null do count := count + 1;
foundlen := count;
for count := length(found) + 1 to 15 { 13 } do
found := found + ' ';
if (attribute AND seekattrib) > 0
then subdir := TRUE
else subdir := FALSE;
if NOT subdir
then size := sizeoffile(sizehigh,sizelow)
else size := 0.0;
end;
end;
procedure findnext(var found : filename;
var size : real;
var lastone : boolean;
var subdir : boolean);
const findnext = $4F00;
var regs : registers;
count : integer;
foundlen : byte absolute found;
begin
with regs do
begin
ax := findnext;
MsDos(regs);
if ((flags AND 1) > 0) AND (ax = 18)
then lastone := TRUE
else lastone := FALSE;
end;
with transferrec^ do
begin
found := foundname;
count := 0;
while found[count] <> null do count := count + 1;
foundlen := count;
for count := length(found) + 1 to 15 { 13 } do
found := found + ' ';
if (attribute AND seekattrib) > 0
then subdir := TRUE
else subdir := FALSE;
if NOT subdir
then size := sizeoffile(sizehigh,sizelow)
else size := 0.0;
end;
end;
begin
move(video,local_image,4000);
window(1,1,80,24);
textcolor(15); textbackground(0);
frame(4,3,77,15);
window(5,4,76,14);
clrscr;
write('File Name Pattern: ');
readln(matchptrn);
if matchptrn = '' then matchptrn := '*.*';
count := 0;
pointdta(transferrec);
findfirst(matchptrn,retname,filsize,nofind,lastfile,subdirec);
if nofind OR lastfile
then writeln('File not found.')
else
begin
clrscr;
while (NOT lastfile) do
begin
write(retname ,':',filsize:8:0,' ') ;
count := count + 1;
if count = 30 then
begin
press_key;
count := 0;
end;
findnext(retname,filsize,lastfile,subdirec);
end;
end;
if count < 30 then
begin
writeln;
press_key;
end;
move(local_image,video,4000);
end;
procedure get_file_name(var name : file_type;
xp,yp : integer;
prompt : any_string;
x1,y1,x2,y2 : integer);
var i,x,y : integer;
key : char;
f,b : integer;
begin
name := '';
gotoxy(xp,yp); ClrEol;
writeln('Enter filename <ctrl F> directory');
if prompt > ''
then write('...........[',prompt,'] ')
else write('...........');
repeat
repeat until keypressed;
key := readkey;
if (key = #0) then
begin
key := readkey;
key := null;
end;
if (key = ^F) then
begin
save_attr(f,b,x1,y1);
x := WhereX; y := WhereY;
directory;
restore_attr(f,b);
window(x1,y1,x2,y2);
gotoxy(x,y);
end;
until (key in [^M,chr(32)..chr(127)]);
if (key <> ^M) then
begin
write(key);
name := key;
repeat
key := readkey;
if (key = ^H) and (ord(name[0]) > 0)
then
begin
name[0] := chr(ord(name[0]) - 1);
write(^H,' ',^H);
end
else
if (key > ' ') then
begin
write(key);
name := name + key;
end;
if (key = #0) then key := readkey;
until (key = #13);
end;
end;
procedure UpperCase(VAR str : any_string);
var i : integer;
begin
if length(str) > 0 then
for i := 1 to length(str) do
if str[i] in ['a'..'z'] then str[i] := chr(ord(str[i]) AND $DF);
end;